home *** CD-ROM | disk | FTP | other *** search
- unit UserRes1;
- {
- *********************************************************
- * demo for use of def files with local tables at your *
- * client's site *
- * *
- * (c) 1996-97 Reinhard Kalinke *
- * *
- *********************************************************
- }
-
- {NOTE When compiling the samples or a project of your own using
- BDEDoRxS methods with Delphi 1 tests seem to indicate that you
- better increase stack size to 24 or even 32k.}
-
- interface
-
- uses
- WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls,
- Forms, Dialogs, StdCtrls, FileCtrl, Db, DBTables, Px7Table,
- IniFiles, ExtCtrls,
- {$IFDEF WIN32}
- ComCtrls,
- {$ELSE}
- Gauges,
- {$ENDIF}
- DBIProcs;
-
- type
- TMainForm = class(TForm)
- GroupBox1: TGroupBox;
- AliasCB: TComboBox;
- GroupBox2: TGroupBox;
- DriveBox1: TDriveComboBox;
- DirBox1: TDirectoryListBox;
- GroupBox3: TGroupBox;
- TblCreateCB: TCheckBox;
- IndexCB: TCheckBox;
- DoItBtn: TButton;
- RestTbl: TPx7Table;
- RestDB: TDatabase;
- DeleteCB: TCheckBox;
- ValcheckCB: TCheckBox;
- RefIntCB: TCheckBox;
- Panel1: TPanel;
- Panel2: TPanel;
- IdxCB: TCheckBox;
- Bevel1: TBevel;
- procedure FormShow(Sender: TObject);
- procedure AliasCBChange(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure DoItBtnClick(Sender: TObject);
- procedure ValcheckCBClick(Sender: TObject);
- procedure IdxCBClick(Sender: TObject);
- private
- { Private-Deklarationen }
- FCalced: boolean;
- FBDEVersion: string;
- FDeleteVals: boolean;
- FPreventSizing: boolean;
- {$IFDEF WIN32}
- ProgressBar1: TProgressBar;
- {$ELSE}
- ProgressBar1: TGauge;
- {$ENDIF}
- procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
- message WM_GETMINMAXINFO;
- procedure WMNCHitTest(var Msg: TWMNCHitTest);
- message WM_NCHitTest;
- procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup);
- message WM_INITMENUPOPUP;
- public
- { Public-Deklarationen }
- end;
-
- var
- MainForm: TMainForm;
-
- implementation
-
- {$R *.DFM}
-
- uses BDEDoRxS;
-
- procedure AssignDBDir(ADataBase: TDataBase; const AFileName: TFileName);
- begin
- with ADataBase do
- if (Params.Count = 0)
- or (Params[0] <> 'PATH='+AFileName) then
- begin
- if Connected then Connected := False;
- DriverName := 'STANDARD'; {clears any alias as well}
- Params.Clear;
- Params.Add('PATH='+AFileName);
- Open;
- end;
- end;
-
- {'Wrappers' you might want to paste into your apps/restructors.
- For an example on how to use them check form method DoItBtnClick}
-
- {scans a dir for files with extension AExt and writes them
- into a list for further processing}
- function DoScanDirForFiles(const ADir,AExt: TFileName;
- AList: TStrings): integer;
- var FileRec: TSearchRec;
- ScanDir: TFileName;
- Res: integer;
- begin
- AList.Clear;
- if (ADir[Length(ADir)] <> '\') then ScanDir := ADir+'\'
- else ScanDir := ADir;
- Res := SysUtils.FindFirst(ScanDir+'*.'+AExt, 0, FileRec);
- while Res = 0 do
- begin
- AList.Add(ScanDir+FileRec.Name);
- Res := SysUtils.FindNext(FileRec);
- end;
- SysUtils.FindClose(FileRec);
- Result := AList.Count;
- end;
-
- {writes table defs for a list of tables}
- procedure DoWriteTableDefsToFile(AFileList: TStrings;
- ATable: TTable;
- const AVersion: string;
- DoUseFieldIDs: boolean;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;{}
- {$ENDIF}
- AStatusPanel: TPanel);
- var i,iProg: integer;
- DBFile, DefFile: TFileName;
- begin
- Screen.Cursor := crHourGlass;
- try
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- AProgressBar.Max := AFileList.Count;
- {$ELSE}
- AProgressBar.Progress := 0;
- AProgressBar.MaxValue := AFileList.Count;
- {$ENDIF}
- for i:=0 to pred(AFileList.Count) do
- begin
- DBFile := AFileList.Strings[i];
- DefFile := ChangeFileExt(DBFile,'.dbi');
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ExtractFileName(DBFile);
- ATable.Open;
- AStatusPanel.Caption := 'creating table def: '
- +DefFile;
- AStatusPanel.Update;
- BDESaveTableDefsToFile(ATable, DefFile);
- if (AVersion > '') then
- WriteString('Table','Version',AVersion);
- if DoUseFieldIDs then
- WriteString('Table','FieldCompare','ByFieldID')
- else
- WriteString('Table','FieldCompare','ByFieldName');
- finally
- Free;
- ATable.Close;
- end;
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- end;
-
- {writes index defs only for a list of tables}
- procedure DoWriteIndexDefsToFile(AFileList: TStrings;
- ATable: TTable;
- const AVersion: string;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;
- {$ENDIF}
- AStatusPanel: TPanel);
- var i,iProg: integer;
- DBFile, DefFile: TFileName;
- begin
- Screen.Cursor := crHourGlass;
- try
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- AProgressBar.Max := AFileList.Count;
- {$ELSE}
- AProgressBar.Progress := 0;
- AProgressBar.MaxValue := AFileList.Count;
- {$ENDIF}
- for i:=0 to pred(AFileList.Count) do
- begin
- DBFile := AFileList.Strings[i];
- DefFile := ChangeFileExt(DBFile,'.dbx');
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ExtractFileName(DBFile);
- ATable.Open;
- AStatusPanel.Caption := 'creating index def: '
- +DefFile;
- AStatusPanel.Update;
- BDESaveIndexDefsToFile(ATable, DefFile);
- if (AVersion > '') then
- WriteString('Table','Version',AVersion);
- finally
- Free;
- ATable.Close;
- end;
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- end;
-
- {processes table defs with thw whole range of current
- options (indices, RI, Val)}
- procedure DoRestructureFromFile(AFileList: TStrings;
- ADataBase: TDataBase;
- ATable: TTable;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;
- {$ENDIF}
- AStatusPanel: TPanel;
- const DoCreateTables,
- DoCreateIndices,
- DoCreateRefInt,
- DoCreateValchecks,
- DoDeleteDefs: boolean);
- var i,iProg,iPass,iPasses: integer;
- DefFile, DBFile: TFileName;
- DoIndex: boolean;
- ActionStr: string;
- begin
- Screen.Cursor := crHourGlass;
- try
- DoIndex := DoCreateIndices;
- if (DoCreateRefInt or DoCreateValchecks) then
- iPasses := 2 else iPasses := 1;
- {$IFDEF WIN32}
- AProgressBar.Max := AFileList.Count*(1+ord(DoIndex));
- {$ELSE}
- AProgressBar.MaxValue := AFileList.Count*(1+ord(DoIndex));
- {$ENDIF}
- for iPass:=1 to iPasses do
- begin
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- {$ELSE}
- AProgressBar.Progress := 0;{}
- {$ENDIF}
- if (iPass = 1) then
- ActionStr := 'processing: '
- else
- ActionStr := 'creating RI and/or ValChecks: ';
- for i:=0 to pred(AFileList.Count) do
- begin
- DefFile := AFileList.Strings[i];
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ReadString('Table','Name','');
- AStatusPanel.Caption := ActionStr+ATable.TableName;
- AStatusPanel.Update;
- if (iPass = 2) then
- begin
- ATable.Open;
- {'Bugfix' BDE4.0:}
- if MainForm.FDeleteVals then
- BDEDropValFile(ATable);
- if DoCreateRefInt then
- {dropping existing RI is included
- with below function}
- BDEAddRIFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;{}
- {$ENDIF}
- if DoCreateValchecks then
- {dropping existing val is included
- with below function}
- BDEAddValchecksFromFile(ATable, DefFile); {}
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;{}
- {$ENDIF}
- Continue;
- end
- else
- try
- ATable.Open;
- if DoCreateRefInt then
- BDEDropAllRIConstraints(ATable);
- if DoCreateIndices then
- BDEDropAllIndices(ATable);
- BDERestructTableFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;{}
- {$ENDIF}
- except
- on E:EDBEngineError do
- begin
- DoIndex := False;
- {if table does not exist:}
- if ((E.Errors[pred(E.ErrorCount)].ErrorCode = DBIERR_OSENOENT)
- or (E.Errors[pred(E.ErrorCount)].ErrorCode = DBIERR_NOSUCHTABLE))
- and DoCreateTables then
- begin
- BDECreateTableFromFile(ADataBase, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;{}
- {$ENDIF}
- DoIndex := DoCreateIndices;
- ATable.Open;
- DBISaveChanges(ATable.Handle);
- end
- else raise;
- end;
- else raise;
- end;
- if DoIndex then
- {dropping existing indices is included
- with below function}
- BDEAddIndicesFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;{}
- {$ENDIF}
- finally
- Free;
- ATable.Close;
- end;
- end;
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- if DoDeleteDefs then
- begin
- for i:=0 to pred(AFileList.Count) do
- SysUtils.DeleteFile(AFileList.Strings[i]);
- end;
- end;
-
- {processes table defs for field restructure and indices only
- (no RI or Val processing)}
- procedure DoSimpleRestructureFromFile(AFileList: TStringList;
- ADataBase: TDataBase;
- ATable: TTable;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;
- {$ENDIF}
- AStatusPanel: TPanel;
- const DoCreateTables,
- DoCreateIndices,
- DoDeleteDefs: boolean);
- var i,iProg: integer;
- DefFile, DBFile: TFileName;
- DoIndex: boolean;
- Res: integer;
- FileRec: TSearchRec;
- begin
- Screen.Cursor := crHourGlass;
- try
- DoIndex := DoCreateIndices;
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- AProgressBar.Max := AFileList.Count*(1+ord(DoIndex));
- {$ELSE}
- AProgressBar.Progress := 0;
- AProgressBar.MaxValue := AFileList.Count*(1+ord(DoIndex));
- {$ENDIF}
- for i:=0 to pred(AFileList.Count) do
- begin
- DefFile := AFileList.Strings[i];
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ReadString('Table','Name','');
- AStatusPanel.Caption := 'processing: '+ATable.TableName;
- AStatusPanel.Update;
- try
- ATable.Open;
- if DoCreateIndices then
- BDEDropAllIndices(ATable);
- BDERestructTableFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- except
- on E:EDBEngineError do
- begin
- DoIndex := False;
- {if table does not exist:}
- if ((E.Errors[pred(E.ErrorCount)].ErrorCode = DBIERR_OSENOENT)
- or (E.Errors[pred(E.ErrorCount)].ErrorCode = DBIERR_NOSUCHTABLE))
- and DoCreateTables then
- begin
- BDECreateTableFromFile(ADataBase, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- DoIndex := DoCreateIndices;
- ATable.Open;
- DBISaveChanges(ATable.Handle);
- end
- else raise;
- end;
- else raise;
- end;
- if DoIndex then
- BDEAddIndicesFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- finally
- Free;
- ATable.Close;
- end;
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- if DoDeleteDefs then
- begin
- for i:=0 to pred(AFileList.Count) do
- SysUtils.DeleteFile(AFileList.Strings[i]);
- end;
- end;
-
- {processes defs for indices only}
- procedure DoProcessIndicesFromFile(AFileList: TStringList;
- ATable: TTable;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;
- {$ENDIF}
- AStatusPanel: TPanel;
- const DoDeleteDefs: boolean);
- var i,iProg,iPass,iPasses: integer;
- DefFile, DBFile: TFileName;
- Res: integer;
- FileRec: TSearchRec;
- begin
- Screen.Cursor := crHourGlass;
- try
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- AProgressBar.Max := AFileList.Count;
- {$ELSE}
- AProgressBar.Progress := 0;
- AProgressBar.MaxValue := AFileList.Count;
- {$ENDIF}
- for i:=0 to pred(AFileList.Count) do
- begin
- DefFile := AFileList.Strings[i];
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ReadString('Table','Name','');
- AStatusPanel.Caption := 'creating indices: '+ATable.TableName;
- AStatusPanel.Update;
- ATable.Open;
- {dropping indices is included with below function}
- BDEAddIndicesFromFile(ATable, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- finally
- Free;
- ATable.Close;
- end;
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- if DoDeleteDefs then
- begin
- for i:=0 to pred(AFileList.Count) do
- SysUtils.DeleteFile(AFileList.Strings[i]);
- end;
- end;
-
- {processes index defs for a list of files in case of
- index errors ('Index out of date')}
- procedure DoRecoverIndicesFromFile(AFileList: TStringList;
- ADB: TDataBase;
- ATable: TTable;
- {$IFDEF WIN32}
- AProgressBar: TProgressBar;
- {$ELSE}
- AProgressBar: TGauge;
- {$ENDIF}
- AStatusPanel: TPanel;
- const DoDeleteDefs: boolean);
- var i,iProg,iPass,iPasses: integer;
- DefFile, DBFile: TFileName;
- Res: integer;
- FileRec: TSearchRec;
- begin
- Screen.Cursor := crHourGlass;
- try
- iProg := 0;
- {$IFDEF WIN32}
- AProgressBar.Position := 0;
- AProgressBar.Max := AFileList.Count;
- {$ELSE}
- AProgressBar.Progress := 0;
- AProgressBar.MaxValue := AFileList.Count;
- {$ENDIF}
- for i:=0 to pred(AFileList.Count) do
- begin
- DefFile := AFileList.Strings[i];
- with TIniFile.Create(DefFile) do
- try
- ATable.TableName := ReadString('Table','Name','');
- AStatusPanel.Caption := 'recovering indices: '+ATable.TableName;
- AStatusPanel.Update;
- BDERecoverIndicesFromFile(ADB, ATable.TableName, DefFile);
- inc(iProg);
- {$IFDEF WIN32}
- AProgressBar.Position := iProg;
- {$ELSE}
- AProgressBar.Progress := iProg;
- {$ENDIF}
- finally
- Free;
- end;
- end;
- AStatusPanel.Caption := 'Done!';
- AStatusPanel.Update;
- finally
- Screen.Cursor := crDefault;
- end;
- if DoDeleteDefs then
- begin
- for i:=0 to pred(AFileList.Count) do
- SysUtils.DeleteFile(AFileList.Strings[i]);
- end;
- end;
- {end of 'wrapper' section}
-
- procedure TMainForm.DoItBtnClick(Sender: TObject);
- var AFileList: TStringList;
- i: integer;
- begin
- if (AliasCB.Text <> 'use Directories') then
- begin
- RestDB.Close;
- RestDB.Params.Clear;
- RestDB.AliasName := AliasCB.Text;
- RestDB.Open;
- end
- else
- AssignDBDir(RestDB,DirBox1.Directory);
- AFileList := TStringList.Create;
- try
- if IdxCB.Checked then
- begin
- if (DoScanDirForFiles(DirBox1.Directory,'DBX',AFileList) > 0) then
- DoRecoverIndicesFromFile(AFileList,RestDB,RestTbl,
- ProgressBar1,Panel1,
- DeleteCB.Checked)
- else
- ShowMessage('No files to process');
- end
- else
- begin
- if (DoScanDirForFiles(DirBox1.Directory,'DBI',AFileList) > 0) then
- DoRestructureFromFile(AFileList,RestDB,RestTbl,ProgressBar1,Panel1,
- TblCreateCB.Checked,IndexCB.Checked,
- RefIntCB.Checked,ValcheckCB.Checked,
- DeleteCB.Checked)
- else
- ShowMessage('No files to process');
- end;
- finally
- AFileList.Free;
- end;
- end;
-
- procedure TMainForm.FormShow(Sender: TObject);
- begin
- if not FCalced then
- begin
- CalcControlSize(self);
- {$IFDEF WIN32}
- FBDEVersion := BDEGetIdapi32Version;
- {$ELSE}
- FBDEVersion := BDEGetIdapi16Version;
- {$ENDIF}
- FCalced := True;
- FPreventSizing := True;
- end;
- end;
-
- procedure TMainForm.AliasCBChange(Sender: TObject);
- begin
- if (AliasCB.Text <> 'use Directories') then
- DirBox1.Directory := BDEGetDBPath(AliasCB.Text);
- DirBox1.Enabled := (AliasCB.Text = 'use Directories');
- DriveBox1.Enabled := (AliasCB.Text = 'use Directories');
- end;
-
- procedure TMainForm.FormCreate(Sender: TObject);
- begin
- {$IFDEF WIN32}
- ProgressBar1 := TProgressBar.Create(self);
- {$ELSE}
- ProgressBar1 := TGauge.Create(self);
- {$ENDIF}
- with ProgressBar1 do
- begin
- Parent := Panel2;
- Align := alClient;
- Visible := True;
- end;
- Session.GetAliasNames(AliasCB.Items);
- AliasCB.Items.Insert(0,'use Directories');
- AliasCB.ItemIndex := 0;
- end;
-
- procedure TMainForm.ValcheckCBClick(Sender: TObject);
- begin
- if ValcheckCB.Checked and (FBDEVersion = '4.00') then
- case MessageDlg('You are using version '+FBDEVersion+' of BDE.'+#13#10
- +'Due to a serious bug in this version there is no way'+#13#10
- +'valcheck deletes correctly'+#13#10
- +#13#10
- +'Possible remedies:'+#13#10
- +#13#10
- +'Choose "Yes" to delete all *.VAL files before (re-)creation.'+#13#10
- +'Note that this will also delete all RI checks for the tables'+#13#10
- +'Don''t forget to recreate them as well.'+#13#10
- +#13#10
- +'Choose "No" for an internal error handling that will not'+#13#10
- +'delete the checks but only "null" them.',
- mtConfirmation,mbYesNoCancel,0) of
- mrYes: FDeleteVals := True;
- mrNo: FDeleteVals := False;
- mrCancel: ValcheckCB.Checked := False;
- end;
- end;
-
- procedure TMainForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
- begin
- inherited;
- if FPreventSizing then
- with (self), Msg.MinMaxInfo^ do
- begin
- ptMinTrackSize.x:= Width;
- ptMaxTrackSize.x:= Width;
- ptMinTrackSize.y:= Height;
- ptMaxTrackSize.y:= Height;
- end;
- end;
-
- procedure TMainForm.WMInitMenuPopup(var Msg: TWMInitMenuPopup);
- begin
- inherited;
- if FPreventSizing and Msg.SystemMenu then
- begin
- EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_GRAYED);
- EnableMenuItem(Msg.MenuPopup, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);
- end;
- end;
-
- procedure TMainForm.WMNCHitTest(var Msg: TWMNCHitTest);
- begin
- inherited;
- if FPreventSizing then
- with Msg do
- if Result in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT,
- HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then
- Result := longint(HTNOWHERE);
- end;
-
- procedure TMainForm.IdxCBClick(Sender: TObject);
- begin
- IndexCB.Enabled := (not IdxCB.Checked);
- RefIntCB.Enabled := (not IdxCB.Checked);
- ValcheckCB.Enabled := (not IdxCB.Checked);
- TblCreateCB.Enabled := (not IdxCB.Checked);
- {$IFDEF WIN32}
- ProgressBar1.Position := 0;
- {$ELSE}
- ProgressBar1.Progress := 0;
- {$ENDIF}
- Panel1.Caption := ' Idle...';
- end;
-
- end.
-